COMMENT ⊗   VALID 00006 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	              L A P A C K   .   V L I                     
C00005 00003	 MACLAP du compilateur 
C00007 00004	 *LAPAK1 : tasse 1 instruction , *LAPAK : auxilliaire 
C00010 00005	 *LAPAKADR : calcule 1 adresse 
C00012 00006	 LAPACK LAPACKFILE LAPACKF 
C00014 ENDMK
C⊗;
;              L A P A C K   .   V L I                     ;
;         Compacteur de LAP   VLISP 10 . 3                 ;
;----------------------------------------------------------;
;       Jerome CHAILLOUX                                   ;
;                                                          ;
;       Universite de Paris VIII - Vincennes               ;
;       Route de la Tourelle 75012 Paris                   ;
;       Tel : 374 12 50 poste 299                          ;
;                                                          ;
;       I.R.C.A.M.                                         ;
;       31 Rue St Merri 75004 Paris                        ;
;       Tel : 277 12 33 poste 48-48                        ;
;----------------------------------------------------------;
;							   ;
; regles de reconnaissance des identificateurs :  	   ;
;							   ;
;   1er car.         signification			   ;
;							   ;
;	&	fonctions d'echappements (ESCAPEs)         ;
;	*	fonctions internes du lapack		   ;
;	-	variables globales a tout le lapack	   ;
;	#	variables libres pour certaines fonctions  ;
;		(mais liees par des fonctions du lapack)   ;
;	!	indicateurs sur P-listes		   ;
;	?	indicateurs du lapack (e.g. T ou NIL)      ;
;	:	symboles du LINK 10 connus du lapack 	   ;
;							   ;
;----------------------------------------------------------;
;;
; initialisations ;
;;
(STATUS 2 2)
;;
; pour eviter tout malentendu ... ;
 
(MAPC '(@ : + * % ! # $ & ?) (LAMBDA (X) (STATUS 19 X)))
 
;;
; INIT :MEM et :BCODEC ;
 
(SETQ :MEM (GETSYMBOL ':MEM))
(SETQ :BCODEE (STATUS 41 (GETSYMBOL ':BCODEE)))
; MACLAP du compilateur ;
 
  (DF MACLAP (L)
      ; definition d'une macro-LAP ;
      (PUT (CAR L) (CONS LAMBDA (CDR L)) '!maclap))
 
  (DF TMACLAP (L)
      ; test des macros du lod/lap ;
      (APPLY (GET (CAR L) '!maclap) (CDR L))))

  (DE ACCESS (REGD REGS)
      ; donne acces a regs (pour les mac-laps) ;
      (CONS REGD
	(IF (LISTP REGS)
	   (COND
	      ((EQ (CAR REGS) QUOTE)
		 ; constante VLISP ;
		 [[':MEM REGS]])
	      ((EQ (CAR REGS) '%)
		 ; objet en pile ;
		 ['@ (CADR REGS) 'P])
	      ([REGS]))
	   ; acces normal ;
	   [':MEM REGS])))
 
  ; Macros Lap du compilateur ;
 
  (MACLAP MACLAP (ATOM L X) (PUT ATOM [LAMBDA L X] '!maclap) NIL)
  (MACLAP GETVAL (REGD ATOM) [['HLRZ REGD [':MEM [QUOTE ATOM]]]])
  (MACLAP PUTVAL (REGS ATOM) [['HRLM REGS [':MEM [QUOTE ATOM]]]])
  (MACLAP SETNIL (ATOM) [['HRRZS 0 [':MEM [QUOTE ATOM]]]])
  (MACLAP CAR (REGD REGS) [(CONS 'HLRZ (ACCESS REGD REGS))])
  (MACLAP CDR (REGD REGS) [(CONS 'HRRZ (ACCESS REGD REGS))])
  (MACLAP RPLACA (REGS REGD) [(CONS 'HRLM (ACCESS REGD REGS))])
  (MACLAP RPLACD (REGS REGD) [(CONS 'HRRM (ACCESS REGD REGS))])
  (MACLAP ARRAY (REGD ATOM) [['HRRZ REGD ['+ ':MEM 5 [QUOTE ATOM]]]])
; *LAPAK1 : tasse 1 instruction , *LAPAK : auxilliaire ;

(DE *LAPAK1 (L) (SETQ L (*LAPAK L)) (AND L (PRIN1 L)))

(DE *LAPAK (L ;; R X)
   (COND
      ((ATOM L) ; aucun atome n'est transforme ; L)
      ((AND (LITATOM (CAR L)) (SETQ R (GET (CAR L) '!maclap)))
	; appel de Macros-Lap ;
	(MAPC (APPLY R (CDR L)) '*LAPAK1))
      ((SELECTQ (CAR L)
	((* COMMENT VALAP MACLAP EVAL REGISTER 
	  END ENTRY OPCD QUOTE)
	  ; reste identique ;
	  L)
	(EXP (SETQ R (*LAPAKADR (CADR L)))
	   (IF (NUMBP R) R L))
	((XWD LIST)
	    (SETQ R [(*LAPAKADR (CADR L)) (*LAPAKADR (CADDR L))])
	    (IF (AND (NUMBP (CAR R)) (NUMBP (CADR R)))
		(LOGOR (LOGSHIFT (CAR R) 18) (LOGAND (CADR R) \777777))
		(CONS 'LIST R)))
	(T ; instruction donc normale ;
	   (SETQ X L)
	   (SETQ R (COND ((NUMBP (CAR X))) 
			((OPCD (CAR X)))
			((CAR X))))
	   (RPLACA X R)
	   (OR (CDR X) (RPLACD X [0]))
	   (NEXTL X)
           (SETQ R (OR (REGISTER (CAR X)) (CAR X)))
	   (RPLACA X R)
	   (OR (CDR X) (RPLACD X [0]))
	   (NEXTL X)
	   (IF (NEQ (CAR X) '@)
			(ATTACH 0 X)
			(RPLACA X R))
	   (OR (CDR X) (RPLACD X [0]))
	   (NEXTL X)
	   (SETQ R (*LAPAKADR (CAR X)))
	   (RPLACA X R)
	   (OR (CDR X) (RPLACD X [0]))
	   (NEXTL X)
	   (SETQ R (OR (REGISTER (CAR X)) (CAR X)))
	   (RPLACA X R)
	   (IF (EVERY L 'NUMBP)
	      (STATUS 44 L)
	      (IF (AND (NUMBP (CAR L)) (NUMBP (CADR L))
			(NUMBP (CADDR L)) (NUMBP (CAR (CDDDDR L))))
		['LIST
		  (SWAP (STATUS 44 [(CAR L) (CADR L) 
					 (CADDR L) 0 (CAR (CDDDDR L))]))
		  (CADDDR L)]
	      L)))))))))))
; *LAPAKADR : calcule 1 adresse ;

(DE *LAPAKADR (adress)
   (COND
      ((NULL adress) ; pas d'adresse ; 0)
      ((NUMBP adress) ; adr absolue ; adress)
      ((ATOM adress)
	 (COND
	   ((SAMEPN adress ':)
	      ; symbole du LINK 10 ;
	      (OR (GETSYMBOL adress) adress))
           ((AND (LE (LOC adress) (LOC 'STOP)) 
		 (NOT (MEMQ 'ENTRY (CDR adress))))  
	      ; vraie adresse de fonction systeme ;
	      (LOGAND \777777 (STATUS 41 (PLUS :MEM 5 (LOC adress)))))
	   (T ; autre type ; adress)))
      ((EQ (CAR adress) QUOTE) 
          ; objet LISP ;
	  (IF (OR (INUMBP (CADR adress))
		  (LE (LOC (CADR adress)) (LOC 'STOP)))
	       (LOC (CADR adress)) 
	       adress))
      (T ; c'est une adresse plus compliquee ; adress))))

; LAPACK LAPACKFILE LAPACKF ;

(DE LAPACK (L ;; R)
  ; tasse la liste d'instructions L ;
  (PUSH (STATUS 0)) (STATUS 1 24)
  (MAPC L '(LAMBDA (L)
	; a cause des structure partagees du compilo ;
	(*LAPAK1 (IF (ATOM L) L (APPEND L)))))
  (STATUS 0 (POP)))


(DE LAPACKFILE (filout filin)
   ; tasse le fichier <filin> dans le fichier <filout> ;
   (INPUT filin)
   (STATUS 2 20) (STATUS 1 24)
   (OUTPUT filout)
   ; effectue le 1er EVAL qui positionne les indics ENTRY ;
   (EVAL (CADR (PRINT (READ))))
   (DE EOF () (REMPROP 'EOF EXPR)
	(STATUS 1 20) (STATUS 2 24)
	(&EOF))
   (ESCAPE &EOF (WHILE T (*LAPAK1 (READ))))
   (TERPRI) 
   (OUTPUT)
   (INPUT)
   filout))

(DF LAPACKF (F)
   ; forme simplifiee de LAPACKFILE ;
   (LAPACKFILE 
	['DSK (CONS (CAR F) 'VLO) (GETPPN) \055]
	['DSK (CONS (CAR F) 'VLA)]))

(POUR EVAL (MAPC (MAPCAR (MAKLIST "SYS:LAPACK.VLI loaded.
") 'CASCII) 'TYO)))